Network Support Library/RoseWare - Network Support Library.iso/apidev/netman.arc/LEADER.PAS

Pascal/Delphi Source File | 1989-05-22 | 6KB | 351 lines

{$define WEAVE}

program Leader;

uses Drivers, Graph, DOS, CRT;

const GraphMode = MCGAC0;
      GraphDriver = MCGA;
      Block = 50;
      ScreenMap = $b800;
      BitsPerHue = 2;
      Threshold = 4;
      Path='.';
      Painting = 'FRACTAL.DAT';
      Framework = 'VALUES.DAT';

{$ifdef WEAVE}
      Interlace = true;
      ScreenMap2 = $ba00;
      HalfLine = 100;
{$else}
      Interlace = false;
{$endif}

const No_Error = $00;
      Not_Found = $02;
      Access_Denied = $05;

const Read_Only = $00;
      Write_Only = $01;
      Read_Write = $02;
      Deny_All = $10;
      Deny_Write = $20;
      Deny_Read = $30;
      Deny_None = $40;

type Border = (Upper, Lower, Leftmost, Rightmost);
     Count_Type = byte;
     Size_Type = word;
     Real_Type = real;

var Hues: byte;
    Fence: array[Border] of Real_Type;

procedure Arrive;

procedure Property;

var Xasp,
    Yasp: word;
    Width,
    Height: longint;
    Adjust: real;

begin
GetAspectRatio(Xasp, Yasp);
Width:=(GetMaxX + 1) * Xasp;
Height:=(GetMaxY + 1) * Yasp;
if Width > Height
then begin
     Adjust:=2 * (Width / Height);
     Fence[Upper]:=2;
     Fence[Lower]:=-2;
     Fence[Leftmost]:=-Adjust;
     Fence[Rightmost]:=Adjust;
     end
else begin
     Adjust:=2 * (Height / Width);
     Fence[Upper]:=Adjust;
     Fence[Lower]:=-Adjust;
     Fence[Leftmost]:=-2;
     Fence[Rightmost]:=2;
     end;
end;

var Mode,
    Driver,
    Result: integer;

begin
Mode:=GraphMode;
Driver:=GraphDriver;
Result:=RegisterBGIdriver(@CGADriverProc);
InitGraph(Driver, Mode, Path);
Hues:=GetMaxColor + 1;
Property;
end;

type Shape = record
               Sound: boolean;
               ForeV,
               RearV: Size_Type;

               H,
               V: Size_Type;
               Most: Count_Type;
               BitPixel,
               PixelByte: byte;
               ByteLine: word;
               Top,
               Left,
               YInc,
               XInc: Real_Type;
               Weave: boolean;
             end;

var Seed: Shape;
    Canvas: file;

const Outgoing = true;
      Incoming = false;

{$ifdef WEAVE}

procedure Door(Outgoing: boolean);

var Size: word;
    Screen: pointer;

begin
Screen:=Ptr(ScreenMap, $0);
with Seed
do begin
   Size:=Block * ByteLine;
   if Outgoing
   then begin
        Rewrite(Canvas, ByteLine);
        BlockWrite(Canvas, Screen^, HalfLine);
        Screen:=Ptr(ScreenMap2, 0);
        BlockWrite(Canvas, Screen^, HalfLine);
        end
   else begin
        FileMode:=Read_Only + Deny_None;
        Reset(Canvas, ByteLine);
        BlockRead(Canvas, Screen^, HalfLine);
        Screen:=Ptr(ScreenMap2, 0);
        BlockRead(Canvas, Screen^, HalfLine);
        end;
   end;
Close(Canvas);
end;

{$else}

procedure Door(Outgoing: boolean);

var Size: word;
    Lines: Size_Type;
    Screen: pointer;

begin
Screen:=Ptr(ScreenMap, $0);
with Seed
do begin
   Size:=Block * ByteLine;
   if Outgoing
   then Rewrite(Canvas, ByteLine)
   else begin
        FileMode:=Read_Only + Deny_None;
        Reset(Canvas, ByteLine);
        end;
   Lines:=V1;
   repeat
     if Outgoing
     then BlockWrite(Canvas, Screen^, Block)
     else BlockRead(Canvas, Screen^, Block);
     Inc(longint(Screen), Size);
     Dec(Lines, Block);
   until (Lines = 0)
   end;
Close(Canvas);
end;

{$endif}

procedure Blend;

begin
end;

procedure Cultivate;

const On = true;
      Off = false;

procedure Plant;

const BitByte = 8;

var Notice: file of Shape;

begin
with Seed
do begin
   Sound:=Off;
   V:=GetMaxY + 1;
   ForeV:=V;
   RearV:=V;
   H:=GetMaxX + 1;
   Most:=Threshold;
   BitPixel:=BitsPerHue;
   PixelByte:=BitByte div BitPixel;
   ByteLine:=H div PixelByte;
   Top:=Fence[Upper];
   Left:=Fence[Leftmost];
   YInc:=(Fence[Upper] - Fence[Lower]) / V;
   XInc:=(Fence[Rightmost] - Fence[Leftmost]) / H;
   Weave:=Interlace;
   end;
Assign(Canvas, Painting);
Door(Outgoing);
Assign(Notice, Framework);
Rewrite(Notice);
Write(Notice, Seed);
Close(Notice);
end;

procedure Grow;

type Header = record
                Sound: boolean;
                AtV,
                ToV: Size_Type;
              end;

var Eye: file of Header;

procedure Ready;

begin
FileMode:= Read_Write + Deny_None;
Assign(Eye, Framework);
end;

var Line: string;

function Ripe: boolean;

var Result: word;
    Place: Header;

begin
{$i-}
Reset(Eye);
{$i+}
Result:=IOResult;
if (Result = No_Error)
then begin
     Read(Eye, Place);
     Close(Eye);
     Str(Place.AtV, Line);
     end;
Ripe:=(Result = Not_Found);
end;

const Time = 500;

begin
Ready;
Line:='';
repeat
  SetColor(White);
  OutTextXY(0,0,Line);
  Delay(Time);
  SetColor(Black);
  OutTextXY(0,0,Line);
until Ripe;
end;

procedure Harvest;

begin
Door(Incoming);
end;

begin
Plant;
Grow;
Harvest;
end;

procedure NewRegion;

const Step = 4;

const Scan = #0;
      Enter = #13;
      Up = #72;
      Down = #80;
      Left = #75;
      Right = #77;
      Reduce = #115;
      Enlarge = #116;

var Key: char;
    Xasp,
    Yasp: word;
    X,
    Y,
    Width,
    Height: Size_Type;
    Ratio: Real_Type;

begin
X:=GetMaxX div 2;
Y:=GetMaxY div 2;
Width:=GetMaxX div 2;
Ratio:=Seed.V / Seed.H;
SetWriteMode(XORPut);
SetColor(Random(GetMaxColor) + 1);
repeat
  Height:=round(Width * Ratio);
  Rectangle(X - Width, Y - Height, X + Width, Y + Height);
  Key:=ReadKey;
  Rectangle(X - Width, Y - Height, X + Width, Y + Height);
  if Key = Scan
  then begin
       Key:=ReadKey;
       case Key
       of Up: Dec(Y, Step);
          Left: Dec(X, Step);
          Right: Inc(X, Step);
          Down: Inc(Y, Step);
          Reduce: Dec(Width, Step);
          Enlarge: Inc(Width, Step);
       end;
       end;
until Key = Enter;
Fence[Upper]:=Fence[Upper] - Seed.YInc * (Y - Height);
Fence[Lower]:=Fence[Lower] + Seed.YInc * (GetMaxY - Y - Height);
Fence[Leftmost]:=Fence[Leftmost] + Seed.XInc * (X - Width);
Fence[Rightmost]:=Fence[Rightmost] - Seed.XInc * (GetMaxX - X - Width);
end;

procedure Depart;

begin
CloseGraph;
end;

var key:char;

begin
Arrive;
repeat
  Cultivate;
  NewRegion;
until false;
Depart;
end.